home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Games of Daze
/
Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso
/
x2ftp
/
msdos
/
crypt
/
dearc31
/
dearc.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-07-26
|
10KB
|
422 lines
Program Dearc;
(*
DEARC.PAS - Program to extract all files from an archive created by version
5.12 or earlier of the ARC utility.
ARC is COPYRIGHT 1985-1988 by System Enhancement Associates.
PKARC/PKXARC are Copyright 1986-1988 by PKWARE, Inc.
This program requires Turbo Pascal Version 4.0 or higher.
Usage: DEARC arcname
arcname is the path/file name of the archive file. All files contained
in the archive will be extracted into the current directory.
HISTORY:
*** ORIGINAL AUTHOR UNKNOWN ***
Version 1.01 - 10/19/85. Changed end-of-file processing to, hopefully, be
more compatible with CPM (whatever that is).
Version 1.01A - 12/19/85 By Roy Collins
Mail: TechMail BBS @ 703-430-2535
- or -
P.O.Box 1192, Leesburg, Va 22075
Modified V1.01 to work with Turbo Pascal Version 2
Added functions ARGC (argument count) and ARGV
(argument value)
Modified all references to "EXIT" command to be
GOTO EXIT, with EXIT defined as a LABEL, at the
end of the function/procedure involved.
Will not accept path names - archives must be in
the current directory.
Version 2.00 - 6/11/86 By David W. Carroll
Mail: High Sierra RBBS-PC @ 209/296-3534
Now supports ARC version 5.12 files, compression
types 7 and 8.
Version 3.00 - 7/30/87 By Richard P. Byrne
UN*X E-Mail: ...!ihnp4!mduxf!rpb
BBS Mail: Software Society BBS @ (201) 729-7410
Modified Version 2.00 to handle compression type
9 (ie. Squashed ).
Version 3.10 - 7/26/88 By Paul Roub
BBS Mail: Society BBS (407)-773-2831
FIDONET Programming Echo
FIDONET C Echo
Compuserve EasyPlex to [71131,157]
Modified Version 3.00:
Ported to Turbo Pascal v4.0
Added Time/Date stamping of extracted files
Removed all floating point
Added confirmation when overwriting existing file
Display type of decompression being done
Updated docs
Removed CP/M style end-of-file padding (do you
really want a bunch of Control-Z's at the
end of a .COM file?)
By the way, argc and argv are gone, and of
COURSE you can use pathnames...
*)
(*
* other units involved
*)
uses
dearcabt, (* abort() routine *)
dearcglb, (* global variables, types *)
dearcio, (* input/output routines *)
dearcunp, (* unPacking stuff *)
dearcusq, (* unSqueezing routines *)
dearclzw; (* LZW (unCrunching and unSquashing *)
(**
*
* Name: function fn_to_str
* Description: convert strings from C format (trailing 0) to Turbo Pascal
* format (leading length byte).
* Parameters: var -
* fn : fntype : filename to convert
* Returns: converted filename
*
**)
function fn_to_str(var fn : fntype) : strtype;
var
s : strtype;
i : integer;
begin
s := '';
i := 0;
while fn[i] <> #0 do
begin
s := s + fn[i];
i := i + 1
end;
fn_to_str := s
end; (* func fn_to_str *)
(**
*
* Name: procedure GetArcName
* Description: get the name of the archive file
* Parameters: none
*
**)
procedure GetArcName;
var
i : integer;
begin
if (ParamCount > 1) then
abort('Too many parameters');
if (ParamCount = 1) then
arcname := ParamStr(1)
else
begin
write('Enter archive filename: ');
readln(arcname);
if arcname = '' then
abort('No file name entered');
writeln;
writeln;
end;
for i := 1 to length(arcname) do
arcname[i] := UpCase(arcname[i]);
if pos('.', arcname) = 0 then
arcname := arcname + '.ARC'
end; (* proc GetArcName *)
(**
*
* Name: function readhdr
* Description: read a file header from the archive file
* Parameters: var -
* hdr : heads - header to read
* Returns: FALSE : eof found
* TRUE : header found
*
**)
function readhdr(var hdr : heads) : boolean;
label
exit;
var
name : fntype;
try : integer;
begin
try := 10;
if endfile then
begin
readhdr := FALSE;
goto exit (******** was "exit" ************)
end;
while get_arc <> arcmarc do
begin
if try = 0 then
abort(arcname + ' is not an archive');
try := try - 1;
writeln(arcname, ' is not an archive, or is out of sync');
if endfile then
abort('Archive length error')
end; (* while *)
hdrver := get_arc;
if hdrver < 0 then
abort('Invalid header in archive ' + arcname);
if hdrver = 0 then { special end of file marker }
begin
readhdr := FALSE;
goto exit (******** was "exit" ************)
end;
if hdrver = 1 then
begin
fread(hdr, sizeof(heads) - sizeof(longint));
hdrver := 2;
hdr.length := hdr.size
end
else
fread(hdr, sizeof(heads));
readhdr := TRUE;
exit:
end; (* func readhdr *)
(**
*
* Name: procedure unpack
* Description: unpack one file
* Parameters: var -
* hdr : heads - header of file to unpack
*
**)
procedure unpack(var hdr : heads);
label
exit;
var
c : integer;
begin
crcval := 0;
size := hdr.size;
state := NOHIST;
FirstCh := TRUE;
case hdrver of
1, 2 :
begin
c := getc_unp;
while c <> -1 do
begin
putc_unp(c);
c := getc_unp
end
end;
3 :
begin
c := getc_unp;
while c <> -1 do
begin
putc_ncr(c);
c := getc_unp
end
end;
4 :
begin
init_usq;
c := getc_usq;
while c <> -1 do
begin
putc_ncr(c);
c := getc_usq
end
end;
5 :
begin
init_ucr(0);
c := getc_ucr;
while c <> -1 do
begin
putc_unp(c);
c := getc_ucr
end
end;
6 :
begin
init_ucr(0);
c := getc_ucr;
while c <> -1 do
begin
putc_ncr(c);
c := getc_ucr
end
end;
7 :
begin
init_ucr(1);
c := getc_ucr;
while c <> -1 do
begin
putc_ncr(c);
c := getc_ucr
end
end;
8 :
decomp(0);
9 :
decomp(1);
else
begin
writeln('I dont know how to unpack file ', fn_to_str(hdr.name));
writeln('I think you need a newer version of DEARC');
fseek(hdr.size, 1);
goto exit (******** was "exit" ************)
end
end; (* case *)
if crcval <> hdr.crc then
writeln('WARNING: File ', fn_to_str(hdr.name), ' fails CRC check');
exit:
end; (* proc unpack *)
(**
*
* Name: procedure extract_file
* Description: extract one file from archive
* Parameters: var -
* hdr : heads - header for file to extract
*
**)
procedure extract_file(var hdr : heads);
var
st : strtype;
ch : char;
fil : file;
begin
extname := fn_to_str(hdr.name);
assign(fil, extname);
{$I-}
reset(fil);
{$I+}
if (ioresult = 0) then
begin
close(fil);
repeat
write(' File ', extname, ' exists. Overwrite (y/n)? ');
readln(st);
ch := upcase(st[1]);
until ((ch = 'Y') or (ch = 'N'));
if (ch = 'N') then
begin
fseek(hdr.size, 1);
writeln(' ', extname, ' skipped.');
exit;
end;
end;
case hdrver of
1, 2 : write('Extracting ');
3 : write('unPacking ');
4 : write('unSqueezing');
5, 6, 7 : write('uncrunching');
8 : write('unCrunching');
9 : write('unSquashing');
end;
writeln(' : ', extname);
open_ext;
unpack(hdr);
close_ext(hdr);
end; (* proc extract *)
(**
*
* Name: procedure extarc
* Description: extract all files from an archive
* Parameters: none
*
**)
procedure extarc;
var
hdr : heads;
begin
open_arc;
while readhdr(hdr) do
extract_file(hdr);
close_arc;
end; (* proc extarc *)
(**
*
* Name: procedure PrintHeading
* Description: print DEARC header info
* Parameters: none
*
**)
procedure PrintHeading;
begin
writeln;
writeln('Turbo Pascal DEARC Utility');
writeln('Version 3.1, 7/26/88');
writeln('Supports Phil Katz "squashed" files');
writeln;
end; (* proc PrintHeading *)
(**
*
* Name: (main routine)
* Description: print header information
* get the archive file name
* do the extraction
*
**)
begin
PrintHeading;
GetArcName; { get the archive file name }
extarc { extract all files from the archive }
end.